home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / cmpnew / cmpvs.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  2KB  |  66 lines
  1. ;;; CMPVS  Value stack manager.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (si:putprop 'vs 'set-vs 'set-loc)
  10. (si:putprop 'vs 'wt-vs 'wt-loc)
  11. (si:putprop 'vs* 'wt-vs* 'wt-loc)
  12. (si:putprop 'ccb-vs 'wt-ccb-vs 'wt-loc)
  13.  
  14. (defvar *vs* 0)
  15. (defvar *max-vs* 0)
  16. (defvar *clink* nil)
  17. (defvar *ccb-vs* 0)
  18. (defvar *initial-ccb-vs*)
  19. (defvar *level* 0)
  20.  
  21. ;;; *vs* holds the offset of the current vs-top.
  22. ;;; *max-vs* holds the maximum offset so far.
  23. ;;; *clink* holds NIL or the vs-address of the last ccb object.
  24. ;;; *ccb-vs* holds the top of the level 0 vs.
  25. ;;; *initial-ccb-vs* holds the value of *ccb-vs* when Pass 2 began to process
  26. ;;; a local (possibly closure) function.
  27. ;;; *level* holds the current function level.  *level* is 0 for a top-level
  28. ;;; function.
  29.  
  30. (defun vs-push ()
  31.   (prog1 (cons *level* *vs*)
  32.          (incf *vs*)
  33.          (setq *max-vs* (max *vs* *max-vs*))))
  34.  
  35. (defun set-vs (loc vs)
  36.   (unless (and (consp loc)
  37.                (eq (car loc) 'vs)
  38.                (equal (cadr loc) vs))
  39.           (wt-nl)
  40.           (wt-vs vs)
  41.           (wt "= " loc ";")))
  42.           
  43. (defun wt-vs (vs)
  44.   (if (= (car vs) *level*)
  45.       (wt "base[" (cdr vs) "]")
  46.       (wt "base" (car vs) "[" (cdr vs) "]")))
  47.  
  48. (defun wt-vs* (vs)
  49.   (if (= (car vs) *level*)
  50.       (wt "(base[" (cdr vs) "]->c.c_car)")
  51.       (wt "(base" (car vs) "[" (cdr vs) "]->c.c_car)")))
  52.  
  53. (defun wt-ccb-vs (ccb-vs)
  54.   (wt "(base0[" (- *initial-ccb-vs* ccb-vs) "]->c.c_car)"))
  55.  
  56. (defun clink (vs) (setq *clink* vs))
  57.  
  58. (defun wt-clink (&optional (clink *clink*))
  59.   (if (null clink) (wt "Cnil") (wt-vs clink)))
  60.  
  61. (defun ccb-vs-push () (incf *ccb-vs*))
  62.  
  63.  
  64.  
  65.  
  66.